home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / examples / xm / vcr < prev   
Encoding:
Text File  |  1991-09-26  |  4.0 KB  |  132 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; VCR simulation
  4.  
  5.  
  6. ;; Initialization
  7.  
  8. (require 'motif)
  9. (load-widgets shell bulletin-board row-column label push-button)
  10.  
  11. (define top (application-initialize 'vcr))
  12. (define con (widget-context top))
  13.  
  14.  
  15. ;; The layout of the VCR's controls
  16.  
  17. (define vcr (create-managed-widget (find-class 'row-column) top))
  18.  
  19. (define panel (create-managed-widget (find-class 'bulletin-board) vcr))
  20.  
  21. (define tape (create-managed-widget (find-class 'push-button) panel))
  22. (set-values! tape 'x 10 'y 10 'width 150 'border-width 2 'label-string 'empty
  23.                   'recompute-size #f
  24.           'activate-callback (list (lambda _ (engine 'load))))
  25.  
  26. (define counter (create-managed-widget (find-class 'push-button) panel))
  27. (set-values! counter 'x 170 'y 10 'width 50 'label-string "0"
  28.              'alignment "alignment_end" 'recompute-size #f)
  29.  
  30. (define function (create-managed-widget (find-class 'push-button) panel))
  31. (set-values! function 'x 230 'y 10 'width 70 'label-string "stop"
  32.                       'recompute-size #f)
  33.  
  34. (define buttons (create-managed-widget (find-class 'row-column) vcr))
  35. (set-values! buttons 'orientation 'horizontal)
  36.  
  37. (define-macro (define-button label activate arm disarm)
  38.   `(let ((b (create-managed-widget (find-class 'push-button) buttons)))
  39.      (set-values! b 'label-string ,label)
  40.      (add-callback b 'activate-callback (lambda _ ,activate))
  41.      (add-callback b 'arm-callback      (lambda _ ,arm))
  42.      (add-callback b 'disarm-callback   (lambda _ ,disarm))))
  43.  
  44. (define-button 'eject (begin (engine 'stop) (engine 'empty)) #f #f)
  45. (define-button 'play  (engine 'play) #f #f)
  46. (define-button 'stop  (engine 'stop) #f #f)
  47. (define-button 'forw  (engine 'forw) (engine 'cue #t) (engine 'cue #f))
  48. (define-button 'rew   (engine 'rew) (engine 'review #t) (engine 'review #f))
  49. (define-button 'pause (engine 'pause) #f #f)
  50.  
  51.  
  52. ;; The `logic' of the VCR
  53.  
  54. (define engine
  55.   (let ((timer #f) (interval) (loaded #f) (cnt 0) (state 'stop))
  56.  
  57.   (define (advance x)
  58.     (set! cnt (modulo (+ cnt x) 10000000))
  59.     (set-values! counter 'label-string (format #f "~s" cnt)))
  60.  
  61.   (define (timeout x)
  62.     (advance x)
  63.     (set! timer (context-add-timeout con interval (lambda _ (timeout x)))))
  64.  
  65.   (define (set-timer when x)
  66.     (stop-timer)
  67.     (set! interval when)
  68.     (set! timer (context-add-timeout con when (lambda _ (timeout x)))))
  69.  
  70.   (define (stop-timer)
  71.     (if timer (remove-timeout timer))
  72.     (set! timer #f))
  73.  
  74.   (define (cue/review on? x)
  75.     (if on?
  76.     (if (not (eq? state 'play))          ; do nothing if not playing
  77.         state
  78.         (set-timer 100 x)                ; else
  79.         'cue/review)
  80.     (if (not (eq? state 'cue/review))    ; do nothing if not in cue/review
  81.         state                            ;   mode
  82.         (set-timer 1000 100)             ; else switch back to play mode
  83.         'play)))
  84.  
  85.   (lambda (op . args)
  86.     (call-with-current-continuation
  87.       (lambda (return)
  88.         (case op
  89.           (load
  90.         (set-values! tape 'label-string 'loaded)
  91.         (set! loaded #t))
  92.           (empty
  93.         (set-values! tape 'label-string 'empty)
  94.         (set! loaded #f))
  95.           (else
  96.         (if (not loaded)
  97.         (return #f))
  98.             (case op
  99.           (stop
  100.         (stop-timer))
  101.           (cue    (set! op (cue/review (car args) 100)))
  102.           (review (set! op (cue/review (car args) -100)))
  103.           (pause
  104.         (cond ((eq? state 'pause)
  105.                (set-timer 1000 100)
  106.                (set! op 'play))
  107.               ((eq? state 'play)
  108.                (stop-timer))
  109.               (else
  110.                (return #f))))
  111.               (forw
  112.          (cond ((eq? state 'pause)
  113.             (advance 4)
  114.             (set! op 'pause))              ; stay in pause mode
  115.                ((not (eq? state 'cue/review))
  116.                 (set-timer 1000 10000))
  117.                (else (set! op state))))        ; stay in the old mode
  118.               (rew
  119.          (cond ((eq? state 'pause)
  120.             (advance -4)
  121.             (set! op 'pause))
  122.                ((not (eq? state 'cue/review))
  123.                 (set-timer 1000 -10000))
  124.                (else (set! op state))))
  125.               (play
  126.              (set-timer 1000 100)))
  127.         (set! state op)
  128.             (set-values! function 'label-string op))))))))
  129.  
  130. (realize-widget top)
  131. (context-main-loop con)
  132.